home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / resource.lisp < prev    next >
Lisp/Scheme  |  1992-04-30  |  26KB  |  697 lines
  1. ;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;; RESOURCE - Lisp version of XLIB's Xrm resource manager
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package :xlib)
  22.  
  23. ;; The C version of this uses a 64 entry hash table at each entry.
  24. ;; Small hash tables lose in Lisp, so we do linear searches on lists.
  25.  
  26. (defstruct (resource-database (:copier nil) (:predicate nil)
  27.                   (:print-function print-resource-database)
  28.                   (:constructor make-resource-database-internal)
  29.                   #+explorer (:callable-constructors nil)
  30.                   )
  31.   (name nil :type stringable :read-only t)
  32.   (value nil)
  33.   (tight nil :type list) ;; List of resource-database
  34.   (loose nil :type list) ;; List of resource-database
  35.   )
  36.  
  37. (defun print-resource-database (database stream depth)
  38.   (declare (type resource-database database)
  39.        (ignore depth))
  40.   (print-unreadable-object (database stream :type t)
  41.     (write-string (string (resource-database-name database)) stream)
  42.     (when (resource-database-value database)
  43.       (write-string " " stream)
  44.       (prin1 (resource-database-value database) stream))))
  45.  
  46. ;; The value slot of the top-level resource-database structure is used for a
  47. ;; time-stamp.
  48.  
  49. (defun make-resource-database ()
  50.   ;; Make a resource-database with initial timestamp of 0
  51.   (make-resource-database-internal :name "Top-Level" :value 0))
  52.  
  53. (defun resource-database-timestamp (database)
  54.   (declare (type resource-database database))
  55.   (resource-database-value database))
  56.  
  57. (defun incf-resource-database-timestamp (database)
  58.   ;; Increment the timestamp
  59.   (declare (type resource-database database))
  60.   (let ((timestamp (resource-database-value database)))
  61.     (setf (resource-database-value database)
  62.       (if (= timestamp most-positive-fixnum)
  63.           most-negative-fixnum
  64.         (1+ timestamp)))))
  65.  
  66. ;; DEBUG FUNCTION  (not exported)
  67. (defun print-db (entry &optional (level 0) type)
  68.   ;; Debug function to print a resource database
  69.   (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]"
  70.       level
  71.       (resource-database-name entry)
  72.       (eq type 'loose)
  73.       (resource-database-value entry))
  74.   (when (resource-database-tight entry)
  75.     (dolist (tight (resource-database-tight entry))
  76.       (print-db tight (+ 2 level) 'tight)))
  77.   (when (resource-database-loose entry)
  78.     (dolist (loose (resource-database-loose entry))
  79.       (print-db loose (+ 2 level) 'loose))))
  80.  
  81. ;; DEBUG FUNCTION
  82. #+comment
  83. (defun print-search-table (table)
  84.   (terpri)
  85.   (dolist (dbase-list table)
  86.     (format t "~%~s" dbase-list)
  87.     (dolist (db dbase-list)
  88.       (print-db db)
  89.       (dolist (dblist table)
  90.     (unless (eq dblist dbase-list)
  91.       (when (member db dblist)
  92.         (format t "  duplicate at ~s" db))))
  93.       )))
  94.  
  95. ;;
  96. ;; If this is true, resource symbols will be compared in a case-insensitive
  97. ;; manner, and converting a resource string to a keyword will uppercaseify it.
  98. ;;
  99. (defparameter *uppercase-resource-symbols* nil)
  100.  
  101. (defun resource-key (stringable)
  102.   ;; Ensure STRINGABLE is a keyword.
  103.   (declare (type stringable stringable))
  104.   (etypecase stringable
  105.     (symbol
  106.       (if (keywordp (the symbol stringable))
  107.       stringable
  108.       (kintern (symbol-name (the symbol stringable)))))
  109.     (string
  110.       (if *uppercase-resource-symbols*
  111.       (setq stringable (#-allegro string-upcase #+allegro correct-case
  112.                 (the string stringable))))
  113.       (kintern (the string stringable)))))
  114.  
  115. (defun stringable-equal (a b)
  116.   ;; Compare two stringables.
  117.   ;; Ignore case when comparing to a symbol.
  118.   (declare (type stringable a b))
  119.   (declare (values boolean))
  120.   (etypecase a
  121.     (string
  122.       (etypecase b
  123.     (string
  124.       (string= (the string a) (the string b)))
  125.     (symbol
  126.       (if *uppercase-resource-symbols*
  127.           (string-equal (the string a)
  128.                 (the string (symbol-name (the symbol b))))
  129.           (string= (the string a)
  130.                (the string (symbol-name (the symbol b))))))))
  131.     (symbol
  132.       (etypecase b
  133.     (string
  134.       (if *uppercase-resource-symbols*
  135.           (string-equal (the string (symbol-name (the symbol a)))
  136.                 (the string b))
  137.           (string= (the string (symbol-name (the symbol a)))
  138.                (the string b))))
  139.     (symbol
  140.       (string= (the string (symbol-name (the symbol a)))
  141.            (the string (symbol-name (the symbol b)))))))))
  142.  
  143.  
  144. ;;;-----------------------------------------------------------------------------
  145. ;;; Add/delete resource
  146.  
  147. (defun add-resource (database name-list value)
  148.   ;; name-list is a list of either strings or symbols. If a symbol, 
  149.   ;; case-insensitive comparisons will be used, if a string,
  150.   ;; case-sensitive comparisons will be used.  The symbol '* or
  151.   ;; string "*" are used as wildcards, matching anything or nothing.
  152.   (declare (type resource-database database)
  153.        (type list name-list) ;; (list stringable)
  154.        (type t value))
  155.   (unless value (error "Null resource values are ignored"))
  156.   (incf-resource-database-timestamp database)
  157.   (do* ((list name-list (cdr list))
  158.     (name (car list) (car list))
  159.     (node database)
  160.     (loose-p nil))
  161.        ((endp list)
  162.     (setf (resource-database-value node) value))
  163.     ;; Key is the first name that isn't *
  164.     (if (stringable-equal name "*")
  165.     (setq loose-p t)
  166.       ;; find the entry associated with name
  167.       (progn
  168.     (do ((entry (if loose-p
  169.             (resource-database-loose node)
  170.               (resource-database-tight node))
  171.             (cdr entry)))
  172.         ((endp entry)
  173.          ;; Entry not found - create a new one
  174.          (setq entry (make-resource-database-internal :name name))
  175.          (if loose-p
  176.          (push entry (resource-database-loose node))
  177.            (push entry (resource-database-tight node)))
  178.          (setq node entry))
  179.       (when (stringable-equal name (resource-database-name (car entry)))
  180.         ;; Found entry - use it
  181.         (return (setq node (car entry)))))
  182.     (setq loose-p nil)))))
  183.  
  184.  
  185. (defun delete-resource (database name-list)
  186.   (declare (type resource-database database)
  187.        (type list name-list))
  188.   (incf-resource-database-timestamp database)
  189.   (delete-resource-internal database name-list))
  190.  
  191. (defun delete-resource-internal (database name-list)
  192.   (declare (type resource-database database)
  193.        (type list name-list)) ;; (list stringable)
  194.   (do* ((list name-list (cdr list))
  195.     (string (car list) (car list))
  196.     (node database)
  197.     (loose-p nil))
  198.        ((endp list) nil)
  199.     ;; Key is the first name that isn't *
  200.     (if (stringable-equal string "*")
  201.     (setq loose-p t)
  202.       ;; find the entry associated with name
  203.       (progn 
  204.     (do* ((first-entry (if loose-p
  205.                    (resource-database-loose node)
  206.                  (resource-database-tight node)))
  207.           (entry-list first-entry (cdr entry-list))
  208.           (entry (car entry-list) (car entry-list)))
  209.          ((endp entry-list)
  210.           ;; Entry not found - exit
  211.           (return-from delete-resource-internal nil))
  212.       (when (stringable-equal string (resource-database-name entry))
  213.         (when (cdr list) (delete-resource-internal entry (cdr list)))
  214.         (when (and (null (resource-database-loose entry))
  215.                (null (resource-database-tight entry)))
  216.           (if loose-p
  217.           (setf (resource-database-loose node)
  218.             (delete entry (resource-database-loose node)
  219.                 :test #'eq :count 1))
  220.         (setf (resource-database-tight node)
  221.               (delete entry (resource-database-tight node)
  222.                   :test #'eq :count 1))))
  223.         (return-from delete-resource-internal t)))
  224.     (setq loose-p nil)))))
  225.  
  226. ;;;-----------------------------------------------------------------------------
  227. ;;; Get Resource
  228.  
  229. (defun get-resource (database value-name value-class full-name full-class)
  230.   ;; Return the value of the resource in DATABASE whose partial name
  231.   ;; most closely matches (append full-name (list value-name)) and
  232.   ;;                      (append full-class (list value-class)).
  233.   (declare (type resource-database database)
  234.        (type stringable value-name value-class)
  235.        (type list full-name full-class)) ;; (list stringable)
  236.   (declare (values value))
  237.   (let ((names (append full-name (list value-name)))
  238.     (classes (append full-class (list value-class))))
  239.     (let* ((result (get-entry (resource-database-tight database)
  240.                   (resource-database-loose database)
  241.                   names classes)))
  242.       (when result
  243.     (resource-database-value result)))))
  244.  
  245. (defun get-entry-lookup (table name names classes)
  246.   (declare (type list table names classes)
  247.        (symbol name))
  248.   (dolist (entry table)
  249.     (declare (type resource-database entry))
  250.     (when (stringable-equal name (resource-database-name entry))
  251.       (if (null (cdr names))
  252.       (return entry)
  253.     (let ((result (get-entry (resource-database-tight entry)
  254.                  (resource-database-loose entry)
  255.                  (cdr names) (cdr classes))))
  256.       (declare (type (or null resource-database) result))
  257.       (when result
  258.         (return result)
  259.         ))))))
  260.  
  261. (defun get-entry (tight loose names classes &aux result)
  262.   (declare (type list tight loose names classes))
  263.   (let ((name (car names))
  264.     (class (car classes)))
  265.     (declare (type symbol name class))
  266.     (cond ((and tight
  267.         (get-entry-lookup tight name names classes)))
  268.       ((and loose
  269.         (get-entry-lookup loose name names classes)))
  270.       ((and tight
  271.         (not (stringable-equal name class))
  272.         (get-entry-lookup tight class names classes)))
  273.       ((and loose
  274.         (not (stringable-equal name class))
  275.         (get-entry-lookup loose class names classes)))    
  276.       (loose
  277.        (loop
  278.          (pop names) (pop classes)
  279.          (unless (and names classes) (return nil))
  280.          (setq name (car names)
  281.            class (car classes))
  282.          (when (setq result (get-entry-lookup loose name names classes))
  283.            (return result))
  284.          (when (and (not (stringable-equal name class))
  285.             (setq result
  286.                   (get-entry-lookup loose class names classes)))
  287.            (return result))
  288.          )))))
  289.  
  290.  
  291. ;;;-----------------------------------------------------------------------------
  292. ;;; Get-resource with search-table
  293.  
  294. (defun get-search-resource (table name class)
  295.   ;; (get-search-resource (get-search-table database full-name full-class) 
  296.   ;;                      value-name value-class)
  297.   ;; is equivalent to 
  298.   ;; (get-resource database value-name value-class full-name full-class)
  299.   ;; But since most of the work is done by get-search-table,
  300.   ;; get-search-resource is MUCH faster when getting several resources with
  301.   ;; the same full-name/full-class
  302.   (declare (type list table)
  303.        (type stringable name class))
  304.   (let ((do-class (and class (not (stringable-equal name class)))))
  305.     (dolist (dbase-list table)
  306.       (declare (type list dbase-list))
  307.       (dolist (dbase dbase-list)
  308.     (declare (type resource-database dbase))
  309.     (when (stringable-equal name (resource-database-name dbase))
  310.       (return-from get-search-resource
  311.         (resource-database-value dbase))))
  312.       (when do-class
  313.     (dolist (dbase dbase-list)
  314.       (declare (type resource-database dbase))
  315.       (when (stringable-equal class (resource-database-name dbase))
  316.         (return-from get-search-resource
  317.           (resource-database-value dbase))))))))
  318.  
  319. (defvar *get-table-result*)
  320.  
  321. (defun get-search-table (database full-name full-class)
  322.   ;; Return a search table for use with get-search-resource.
  323.   (declare (type resource-database database)
  324.        (type list full-name full-class)) ;; (list stringable)
  325.   (declare (values value))
  326.   (let* ((tight (resource-database-tight database))
  327.      (loose (resource-database-loose database))
  328.      (result (cons nil nil))
  329.      (*get-table-result* result))
  330.     (declare (type list tight loose)
  331.          (type cons result))
  332.     (when (or tight loose)
  333.       (when full-name
  334.     (get-tables tight loose full-name full-class))
  335.  
  336.       ;; Pick up bindings of the form (* name). These are the elements of
  337.       ;; top-level loose without further tight/loose databases.
  338.       ;;
  339.       ;; (Hack: these bindings belong in ANY search table, so recomputing them
  340.       ;; is a drag.  True fix involves redesigning entire lookup
  341.       ;; data-structure/algorithm.)
  342.       ;;
  343.       (let ((universal-bindings
  344.           (remove nil loose :test-not #'eq
  345.               :key #'(lambda (database)
  346.                    (or (resource-database-tight database)
  347.                    (resource-database-loose database))))))
  348.     (when universal-bindings
  349.       (setf (cdr *get-table-result*) (list universal-bindings)))))
  350.     (cdr result)))
  351.  
  352. (defun get-tables-lookup (dbase name names classes)
  353.   (declare (type list dbase names classes)
  354.        (type symbol name))
  355.   (declare (optimize speed))
  356.   (dolist (entry dbase)
  357.     (declare (type resource-database entry))
  358.     (when (stringable-equal name (resource-database-name entry))
  359.       (let ((tight (resource-database-tight entry))
  360.         (loose (resource-database-loose entry)))
  361.     (declare (type list tight loose))
  362.     (when (or tight loose)
  363.       (if (cdr names)
  364.           (get-tables tight loose (cdr names) (cdr classes))
  365.         (when tight
  366.           (let ((result *get-table-result*))
  367.         ;; Put tight at end of *get-table-result*
  368.         (setf (cdr result)
  369.               (setq *get-table-result* (cons tight nil))))))
  370.       (when loose
  371.         (let ((result *get-table-result*))
  372.           ;; Put loose at end of *get-table-result*
  373.           (setf (cdr result)
  374.             (setq *get-table-result* (cons loose nil))))))))))
  375.  
  376. (defun get-tables (tight loose names classes)
  377.   (declare (type list tight loose names classes))
  378.   (let ((name (car names))
  379.     (class (car classes)))
  380.     (declare (type symbol name class))
  381.     (when tight
  382.       (get-tables-lookup tight name names classes))
  383.     (when loose
  384.       (get-tables-lookup loose name names classes))
  385.     (when (and tight (not (stringable-equal name class)))
  386.       (get-tables-lookup tight class names classes))
  387.     (when (and loose (not (stringable-equal name class)))
  388.       (get-tables-lookup loose class names classes))
  389.     (when loose
  390.       (loop
  391.     (pop names) (pop classes)
  392.     (unless (and names classes) (return nil))
  393.     (setq name (car names)
  394.           class (car classes))
  395.     (get-tables-lookup loose name names classes)
  396.     (unless (stringable-equal name class)
  397.       (get-tables-lookup loose class names classes))
  398.     ))))
  399.  
  400.  
  401. ;;;-----------------------------------------------------------------------------
  402. ;;; Utility functions
  403.  
  404. (defun map-resource (database function &rest args)
  405.   ;; Call FUNCTION on each resource in DATABASE.
  406.   ;; FUNCTION is called with arguments (name-list value . args)
  407.   (declare (type resource-database database)
  408.        (type (function (list t &rest t) t) function)
  409.        #+clx-ansi-common-lisp
  410.        (dynamic-extent function)
  411.        #+(and lispm (not clx-ansi-common-lisp))
  412.        (sys:downward-funarg function)
  413.        (dynamic-extent args))
  414.   (declare (values nil))
  415.   (labels ((map-resource-internal (database function args name)
  416.          (declare (type resource-database database)
  417.               (type (function (list t &rest t) t) function)
  418.               (type list name)
  419.               #+clx-ansi-common-lisp
  420.               (dynamic-extent function)
  421.               #+(and lispm (not clx-ansi-common-lisp))
  422.               (sys:downward-funarg function))              
  423.          (let ((tight (resource-database-tight database))
  424.            (loose (resource-database-loose database)))
  425.            (declare (type list tight loose))
  426.            (dolist (resource tight)
  427.          (declare (type resource-database resource))
  428.          (let ((value (resource-database-value resource))
  429.                (name (append
  430.                    name
  431.                    (list (resource-database-name resource)))))
  432.            (if value
  433.                (apply function name value args)
  434.              (map-resource-internal resource function args name))))
  435.            (dolist (resource loose)
  436.          (declare (type resource-database resource))
  437.          (let ((value (resource-database-value resource))
  438.                (name (append
  439.                    name
  440.                    (list "*" (resource-database-name resource)))))
  441.            (if value
  442.                (apply function name value args)
  443.              (map-resource-internal resource function args name)))))))
  444.     (map-resource-internal database function args nil)))
  445.  
  446. (defun merge-resources (database with-database)
  447.   (declare (type resource-database database with-database))
  448.   (declare (values resource-database))
  449.   (map-resource
  450.     database
  451.     #'(lambda (name value database)
  452.     (add-resource database name value))
  453.     with-database)
  454.   with-database)
  455.  
  456. (defun char-memq (key char)
  457.   ;; Used as a test function for POSITION
  458.   (declare (type base-char char))
  459.   (member char key))
  460.  
  461. (defmacro resource-with-open-file ((stream pathname &rest options) &body body)
  462.   ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the
  463.   ;; stream
  464.   (let ((abortp (gensym))
  465.     (streamp (gensym)))
  466.     `(let* ((,abortp t)
  467.         (,streamp (streamp pathname))
  468.         (,stream (if ,streamp pathname (open ,pathname ,@options))))
  469.        (unwind-protect
  470.        (multiple-value-prog1
  471.          (progn ,@body)
  472.          (setq ,abortp nil))
  473.      (unless ,streamp
  474.        (close stream :abort ,abortp))))))
  475.  
  476. (defun read-resources (database pathname &key key test test-not)
  477.   ;; Merges resources from a file in standard X11 format with DATABASE.
  478.   ;; KEY is a function used for converting value-strings, the default is
  479.   ;; identity.  TEST and TEST-NOT are predicates used for filtering
  480.   ;; which resources to include in the database.  They are called with
  481.   ;; the name and results of the KEY function.
  482.   (declare (type resource-database database)
  483.        (type (or pathname string stream) pathname)
  484.        (type (or null (function (string) t)) key)
  485.        (type (or null (function (list t) boolean))
  486.                  test test-not))
  487.   (declare (values resource-database))
  488.   (resource-with-open-file (stream pathname)
  489.     (loop
  490.       (let ((string (read-line stream nil :eof)))
  491.     (declare (type (or string keyword) string))
  492.     (when (eq string :eof) (return database))
  493.     (let* ((end (length string))
  494.            (i (position '(#\tab #\space) string
  495.                 :test-not #'char-memq :end end))
  496.            (term nil))
  497.       (declare (type array-index end)
  498.            (type (or null array-index) i term))
  499.       (when i ;; else blank line
  500.         (case (char string i)
  501.           (#\! nil)  ;; Comment - skip
  502.           (#.(card8->char 0) nil) ;; terminator for C strings - skip
  503.           (#\#       ;; Include
  504.            (setq term (position '(#\tab #\space) string :test #'char-memq
  505.                     :start i :end end))
  506.            (when (string-equal string "#INCLUDE" :start1 i :end1 term) 
  507.          (let ((path (merge-pathnames
  508.                    (subseq string (1+ term)) (truename stream))))
  509.            (read-resources database path
  510.                    :key key :test test :test-not test-not))))
  511.           (otherwise
  512.            (multiple-value-bind (name-list value)
  513.            (parse-resource string i end)
  514.          (when name-list 
  515.            (when key (setq value (funcall key value)))
  516.            (when
  517.              (cond (test (funcall test name-list value))
  518.                (test-not (not (funcall test-not name-list value)))
  519.                (t t))
  520.              (add-resource database name-list value))))))))))))
  521.  
  522. (defun parse-resource (string &optional (start 0) end)
  523.   ;; Parse a resource specfication string into a list of names and a value
  524.   ;; string
  525.   (declare (type string string)
  526.        (type array-index start)
  527.        (type (or null array-index) end))
  528.   (declare (values name-list value))
  529.   (do ((i start)
  530.        (end (or end (length string)))
  531.        (term)
  532.        (name-list))
  533.       ((>= i end))
  534.     (declare (type array-index end)
  535.          (type (or null array-index) i term))
  536.     (setq term (position '(#\. #\* #\:) string
  537.              :test #'char-memq :start i :end end))
  538.     (case (and term (char string term))
  539.       ;; Name seperator
  540.       (#\. (when (> term i)
  541.          (push (subseq string i term) name-list)))
  542.       ;; Wildcard seperator
  543.       (#\* (when (> term i)
  544.          (push (subseq string i term) name-list))
  545.        (push '* name-list))
  546.       ;; Value separator
  547.       (#\:
  548.        (push (subseq string i term) name-list)
  549.        (return
  550.      (values
  551.        (nreverse name-list)
  552.        (string-trim '(#\tab #\space) (subseq string (1+ term))))))
  553.       (otherwise
  554.     (return
  555.       (values
  556.         (nreverse name-list)
  557.         (subseq string i term)))))
  558.     (setq i (1+ term))))
  559.  
  560. (defun write-resources (database pathname &key write test test-not)
  561.   ;; Write resources to PATHNAME in the standard X11 format.
  562.   ;; WRITE is a function used for writing values, the default is #'princ
  563.   ;; TEST and TEST-NOT are predicates used for filtering which resources
  564.   ;; to include in the database.  They are called with the name and value.
  565.   (declare (type resource-database database)
  566.        (type (or pathname string stream) pathname)
  567.        (type (or null (function (string stream) t)) write)
  568.        (type (or null (function (list t) boolean))
  569.                  test test-not))
  570.   (resource-with-open-file (stream pathname :direction :output)
  571.     (map-resource
  572.       database
  573.       #'(lambda (name-list value stream write test test-not)
  574.       (when
  575.         (cond (test (funcall test name-list value))
  576.           (test-not (not (funcall test-not name-list value)))
  577.           (t t))
  578.         (let ((previous (car name-list)))
  579.           (princ previous stream)
  580.           (dolist (name (cdr name-list))
  581.         (unless (or (stringable-equal name "*")
  582.                 (stringable-equal previous "*"))
  583.           (write-char #\. stream))
  584.         (setq previous name)
  585.         (princ name stream)))
  586.         (write-string ":    " stream)
  587.         (funcall write value stream)
  588.         (terpri stream)))
  589.       stream (or write #'princ) test test-not))
  590.   database)
  591.  
  592. (defun wm-resources (database window &key key test test-not)
  593.   ;; Takes the resources associated with the RESOURCE_MANAGER property
  594.   ;; of WINDOW (if any) and merges them with DATABASE.
  595.   ;; KEY is a function used for converting value-strings, the default is
  596.   ;; identity.  TEST and TEST-NOT are predicates used for filtering
  597.   ;; which resources to include in the database.  They are called with
  598.   ;; the name and results of the KEY function.
  599.   (declare (type resource-database database)
  600.        (type window window)
  601.        (type (or null (function (string) t)) key)
  602.        (type (or null (function (list t) boolean))
  603.                  test test-not))
  604.   (declare (values resource-database))
  605.   (let ((string (get-property window :RESOURCE_MANAGER :type :STRING
  606.                   :result-type 'string
  607.                   :transform #'xlib::card8->char)))
  608.     (when string
  609.       (with-input-from-string (stream string)
  610.     (read-resources database stream
  611.             :key key :test test :test-not test-not)))))
  612.  
  613. (defun set-wm-resources (database window &key write test test-not)
  614.   ;; Sets the resources associated with the RESOURCE_MANAGER property
  615.   ;; of WINDOW.
  616.   ;; WRITE is a function used for writing values, the default is #'princ
  617.   ;; TEST and TEST-NOT are predicates used for filtering which resources
  618.   ;; to include in the database.  They are called with the name and value.
  619.   (declare (type resource-database database)
  620.        (type window window)
  621.        (type (or null (function (string stream) t)) write)
  622.        (type (or null (function (list t) boolean))
  623.                  test test-not))
  624.   (xlib::set-string-property
  625.     window :RESOURCE_MANAGER
  626.     (with-output-to-string (stream)
  627.       (write-resources database stream :write write
  628.                :test test :test-not test-not))))
  629.  
  630. (defun root-resources (screen &key database key test test-not)
  631.   "Returns a resource database containing the contents of the root window
  632.    RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display,
  633.    then its default screen is used. If an existing DATABASE is given, then
  634.    resource values are merged with the DATABASE and the modified DATABASE is
  635.    returned.
  636.  
  637.    TEST and TEST-NOT are predicates for selecting which resources are
  638.    read.  Arguments are a resource name list and a resource value. The KEY
  639.    function, if given, is called to convert a resource value string to the
  640.    value given to TEST or TEST-NOT."
  641.  
  642.   (declare (type (or screen display) screen)
  643.        (type (or null resource-database) database)
  644.        (type (or null (function (string) t)) key)
  645.        (type (or null (function (list t) boolean)) test test-not)
  646.        (values resource-database))
  647.   (let* ((screen (if (type? screen 'display)
  648.              (display-default-screen screen)
  649.            screen))
  650.      (window (screen-root screen))
  651.      (database (or database (make-resource-database))))
  652.     (wm-resources database window :key key :test test :test-not test-not)
  653.     database))
  654.  
  655. (defun set-root-resources (screen &key test test-not (write #'princ) database)
  656.   "Changes the contents of the root window RESOURCE_MANAGER property for the
  657.    given SCREEN. If SCREEN is a display, then its default screen is used. 
  658.  
  659.    TEST and TEST-NOT are predicates for selecting which resources from the
  660.    DATABASE are written.  Arguments are a resource name list and a resource
  661.    value.  The WRITE function is used to convert a resource value into a
  662.    string stored in the property."
  663.  
  664.   (declare (type (or screen display) screen)
  665.     (type (or null resource-database) database)
  666.     (type (or null (function (list t) boolean)) test test-not)
  667.     (type (or null (function (string stream) t)) write)
  668.     (values resource-database))
  669.   (let* ((screen (if (type? screen 'display)
  670.              (display-default-screen screen)
  671.            screen))
  672.      (window (screen-root screen)))
  673.     (set-wm-resources database window
  674.               :write write :test test :test-not test-not)
  675.     database))
  676.  
  677. (defsetf root-resources set-root-resources)
  678.  
  679. (defun initialize-resource-database (display)
  680.   ;; This function is (supposed to be) equivalent to the Xlib initialization
  681.   ;; code.
  682.   (declare (type display display))
  683.   (let ((rdb (make-resource-database))
  684.     (rootwin (screen-root (car (display-roots display)))))
  685.     ;; First read the server defaults if present, otherwise from the default
  686.     ;; resource file
  687.     (if (get-property rootwin :RESOURCE_MANAGER)
  688.     (xlib:wm-resources rdb rootwin)
  689.       (let ((path (default-resources-pathname)))
  690.     (when (and path (probe-file path))
  691.       (read-resources rdb path))))
  692.     ;; Next read from the resources file 
  693.     (let ((path (resources-pathname)))
  694.       (when (and path (probe-file path))
  695.     (read-resources rdb path)))
  696.     (setf (display-xdefaults display) rdb)))
  697.